home *** CD-ROM | disk | FTP | other *** search
/ Precision Software Appli…tions Silver Collection 4 / Precision Software Applications Silver Collection Volume 4 (1993).iso / new / sampledb.arj / SAMPDBPB.BAS < prev    next >
BASIC Source File  |  1993-08-06  |  15KB  |  489 lines
  1. 'Written by Bill Slamer
  2. 'Declare all Sub Procedures
  3.  DECLARE SUB Printrecords()
  4.  DECLARE SUB Showmenu()
  5.  DECLARE SUB Loadeditfield()
  6.  DECLARE SUB Updaterec()
  7.  DECLARE SUB Editcustomer()
  8.  DECLARE SUB Openfiles()
  9.  DECLARE SUB Sortindex()
  10.  DECLARE SUB Showcustomers()
  11.  DECLARE SUB Deleterecord()
  12.  DECLARE SUB Checkfordups()
  13.  DEFINT A-Z
  14. 'Include anything that the program will use
  15. $INCLUDE"ArrowKey.Inc"
  16.  COLOR 15, 1: CLS
  17.  
  18. SHARED N$(), N(), Fielddesc$(), Fieldlen(),Deleted()
  19. SHARED Editfield$(), MenuRow, Currec, Menu$(), Y$,Deleted
  20. SHARED Maxrows, Row, Currtop, Extnd, Arraylocation
  21. 'Dim all arrays
  22.  DIM N$(1500), N(1500), Fielddesc$(10), Fieldlen(10)
  23.  DIM Editfield$(10), Menu$(10), Deleted(50)
  24.  CLS
  25. 'Define how the record will look
  26.  Type Customerrecord
  27.   'Define the fields in the record
  28.   Company   AS String * 30
  29.   Contact   AS String * 30
  30.   Address1  AS String * 30
  31.   Address2  AS String * 30
  32.   City      AS String * 15
  33.   State     AS String * 2
  34.   Zip       AS String * 10
  35.   Phone     AS String * 13
  36.   Fax       AS String * 13
  37.   Date      AS String * 10
  38.  END Type
  39. 'Set aside memory for the record
  40.  DIM Custrec AS Customerrecord
  41. SHARED Custrec
  42. '*** load Menu Selctions
  43. DATA View all customers, Edit a customer record
  44. DATA Add a customer record,Print all customer records,Quit
  45.  FOR X = 1 TO 5
  46.    READ Menu$(X)
  47.    Menu$(X) = LEFT$("     " + Menu$(X) + SPACE$(50), 50)
  48.  NEXT
  49. '*** load Array With Record Field descriptions
  50.  FOR X = 1 TO 10: READ Fielddesc$(X), Fieldlen(X): NEXT
  51. DATA Company,30,Contact,30,Address1,30,Address2,30,City,15,State,2
  52. DATA Zip,10,Phone,14,Fax,14,Date,10
  53.  Openfiles  'open Any Files That Need To Be Opened
  54.  Sortindex  'sort Index
  55.  Showmenu  'display Menu
  56.  
  57. '------------------------------------------------------------------------------
  58. SUB Checkfordups
  59. SHARED Dup,N$(),Maxrows,Editfield$()
  60.  FOR X=1 TO Maxrows
  61.    IF Editfield$(1)=N$(X) THEN
  62.      Beep:Dup=1
  63.      COLOR 15,4:LOCATE 16,16
  64.      PRINT"The field COMPANY is a DUPLICATE, press any key";
  65.      Z$=INPUT$(1)
  66.      COLOR 15,1:LOCATE 16,16
  67.      PRINT SPACE$(55);
  68.      EXIT FOR
  69.    END IF
  70.  NEXT
  71. END SUB
  72.  
  73. '------------------------------------------------------------------------------
  74. SUB Deleterecord
  75. SHARED Maxrows,Currec,N(),N$(),Deleted(),Deleted,Editfield$(),D$
  76.  COLOR 15,4
  77.  LOCATE 16,14:PRINT"Are you sure you want to delete this record (Y or N)";
  78.  D$=INPUT$(1):D$=UCASE$(D$)
  79.  COLOR 15,1
  80.  IF D$="N" THEN
  81.    LOCATE 16,14:PRINT SPACE$(55);
  82.    EXIT SUB
  83.  END IF
  84.  FOR X=1 TO Maxrows
  85.    IF N$(X)=Editfield$(1) THEN EXIT FOR
  86.  NEXT
  87.  FOR Y=X TO Maxrows
  88.    N$(Y)=N$(Y+1)
  89.    N(Y)=N(Y+1)
  90.  NEXT
  91.  Maxrows=Maxrows-1
  92.  Loaddatafields
  93.  Custrec.Company="DELETED"
  94.  Put#1,Currec,Custrec
  95.  Deleted=Deleted+1
  96.  Deleted(Deleted)=Currec
  97. END SUB
  98.  
  99. '------------------------------------------------------------------------------
  100. SUB Editcustomer
  101. 'This routine lets you EDIT/ADD/DELETE records
  102. SHARED Maxrows,Currec,N(),N$(),Deleted(),Deleted,D$,Dup,EditField$()
  103.  COLOR 15, 1: CLS
  104.  LOCATE 1, 60: PRINT "] Insert OFF ["
  105.  FOR X = 1 TO 10
  106.    COLOR 15, 1: LOCATE X + 4, 11: PRINT Fielddesc$(X)
  107.    IF MenuRow = 3 THEN
  108.      Editfield$(X) = SPACE$(Fieldlen(X))
  109.    END IF
  110.    IF MenuRow = 3 THEN Editfield$(10) = DATE$
  111.    COLOR , 0: LOCATE X + 4, 21: PRINT Editfield$(X)
  112.  NEXT
  113.  IF MenuRow = 2 THEN
  114.    LOCATE 18, 13: PRINT CHR$(24) + CHR$(25) + " " + CHR$(26) + CHR$(27) + " <Alt U>pdate  <ESC> quit  <Ins>  <Alt D>elete"
  115.  ELSE
  116.    LOCATE 18, 20: PRINT CHR$(24) + CHR$(25) + " " + CHR$(26) + CHR$(27) + " <Alt S>ave  <ESC> quit  <Ins>"
  117.  END IF
  118.  
  119.  Row = 1: Col = 1: Nooffields = 10
  120.  DO
  121.    COLOR 0, 7: LOCATE Row + 4, Col + 20
  122.    PRINT MID$(Editfield$(Row), Col, 1)
  123.    X$ = "": WHILE X$ = "": X$ = Inkey$: Wend: X$ = UCASE$(X$)
  124.    COLOR 15, 0: LOCATE Row + 4, Col + 20
  125.    PRINT MID$(Editfield$(Row), Col, 1)
  126.    SELECT CASE X$
  127.      CASE CHR$(0)+Chr$(32)
  128.        Deleterecord
  129.        IF D$="Y" THEN
  130.          EXIT SUB
  131.        END IF
  132.      CASE Esc$
  133.        COLOR 15, 1: CLS
  134.        EXIT SUB
  135.      CASE CHR$(0) + CHR$(22)  'alt U (update Record)
  136. '*** everything Entered Is Stored In Editfield$() array.
  137.        IF MenuRow = 2 THEN    'make Sure Programe Is In Edit Mode
  138.        COLOR 15, 1: CLS  'before Allowing Update.
  139.        Loaddatafields
  140.        Updaterec
  141.        EXIT SUB
  142.      END IF
  143.    CASE CHR$(0) + CHR$(31)  'alt S (save New Record)
  144. '*** everything Entered Is Stored In Editfield$() array.
  145.      IF MenuRow = 3 THEN     'make Sure Program Is In Add Mode
  146.      Checkfordups
  147.      IF Dup=0 THEN
  148.        COLOR 15, 1: CLS   'before Allowing Save.
  149.        Loaddatafields
  150.        Maxrows=Maxrows+1
  151.        IF Deleted>0 THEN
  152.          Currec=Deleted(Deleted)
  153.          Deleted=Deleted-1
  154.          N(Maxrows) = Currec
  155.        ELSE
  156.          Currec = Maxrows+Deleted
  157.          N(Maxrows) = Maxrows
  158.        END IF
  159.        N$(Maxrows) = Custrec.Company
  160.        Updaterec
  161.        Sortindex
  162.        EXIT SUB
  163.      ELSE
  164.        Dup=0
  165.      END IF
  166.    END IF
  167.  CASE Uparrow$
  168.    Col = 1: Row = Row - 1: IF Row < 1 THEN Row = Nooffields
  169.  CASE Dnarrow$, Enter$
  170.    Col = 1: Row = Row + 1: IF Row > Nooffields THEN Row = 1
  171.  CASE Larrow$
  172.    Col = Col - 1: IF Col < 1 THEN Col = Fieldlen(Row)
  173.  CASE Rarrow$
  174.    Col = Col + 1: IF Col > Fieldlen(Row) THEN Col = 1
  175.  CASE Pgup$
  176.    Col = 1: Row = 1
  177.  CASE Pgdn$
  178.    Col = 1: Row = Nooffields
  179.  CASE Ins$
  180.    COLOR , 1
  181.    IF Inc = 1 THEN
  182.      Inc = 0: LOCATE 1, 60: PRINT "] Insert OFF ["
  183.    ELSE
  184.      Inc = 1: LOCATE 1, 60: PRINT "] Insert ON  ["
  185.    END IF
  186.    COLOR , 0
  187.  CASE Del$
  188.    F$ = MID$(Editfield$(Row), Col + 1, Fieldlen(Row))
  189.    F1$ = LEFT$(Editfield$(Row), Col - 1) + F$ + " "
  190.    Editfield$(Row) = F1$
  191.    LOCATE Row + 4, 21: PRINT Editfield$(Row)
  192.  CASE Homek$
  193.    Col = 1: IF Row = 5 OR Row = 6 THEN Col = 2
  194.  CASE Endk$
  195.    Col = Fieldlen(Row)
  196.  CASE Bs$
  197.    IF Col > 1 THEN
  198.      F$ = MID$(Editfield$(Row), Col, Fieldlen(Row))
  199.      F1$ = LEFT$(Editfield$(Row), Col - 2) + F$ + " "
  200.      Editfield$(Row) = F1$
  201.      Col = Col - 1: IF Col < 1 THEN Col = 1
  202.      LOCATE Row + 4, 21: PRINT Editfield$(Row)
  203.    END IF
  204.  CASE  > CHR$(31), < CHR$(126)
  205.    IF Inc = 1 THEN
  206.      F$ = MID$(Editfield$(Row), Col, Fieldlen(Row))
  207.      F1$ = LEFT$(LEFT$(Editfield$(Row), Col - 1) + X$ + F$, Fieldlen(Row))
  208.      Editfield$(Row) = F1$
  209.      Col = Col + 1: IF Col > Fieldlen(Row) THEN Col = 1
  210.      LOCATE Row + 4, 21: PRINT Editfield$(Row)
  211.    ELSE
  212.      MID$(Editfield$(Row), Col) = X$
  213.      LOCATE Row + 4, 21: PRINT Editfield$(Row)
  214.      Col = Col + 1: IF Col > Fieldlen(Row) THEN Col = 1
  215.    END IF
  216.  END SELECT
  217.  LOOP
  218. END SUB
  219.  
  220. '------------------------------------------------------------------------------
  221. SUB Loaddatafields
  222. SHARED Editfield$()
  223.  Custrec.Company = Editfield$(1)
  224.  Custrec.Contact = Editfield$(2)
  225.  Custrec.Address1 = Editfield$(3)
  226.  Custrec.Address2 = Editfield$(4)
  227.  Custrec.City = Editfield$(5)
  228.  Custrec.State = Editfield$(6)
  229.  Custrec.Zip = Editfield$(7)
  230.  Custrec.Phone = Editfield$(8)
  231.  Custrec.Fax = Editfield$(9)
  232.  Custrec.Date = Editfield$(10)
  233. END SUB
  234.  
  235. '------------------------------------------------------------------------------
  236. SUB Loadeditfield
  237. SHARED Maxrows,Currec,N(),N$(),EditField$()
  238.  Currec = N(Row + Extnd)
  239.  Arraylocation = Row + Extnd
  240.  GET #1, Currec, Custrec
  241.  Editfield$(1) = Custrec.Company
  242.  Editfield$(2) = Custrec.Contact
  243.  Editfield$(3) = Custrec.Address1
  244.  Editfield$(4) = Custrec.Address2
  245.  Editfield$(5) = Custrec.City
  246.  Editfield$(6) = Custrec.State
  247.  Editfield$(7) = Custrec.Zip
  248.  Editfield$(8) = Custrec.Phone
  249.  Editfield$(9) = Custrec.Fax
  250.  Editfield$(10) = Custrec.Date
  251. END SUB
  252.  
  253. '------------------------------------------------------------------------------
  254. SUB Openfiles
  255. SHARED Maxrows,Currec,N(),N$(),Deleted(),Deleted
  256.  OPEN "test.txt" FOR RANDOM AS 1 LEN = LEN(Custrec)
  257.  FOR X = 1 TO LOF(1) / LEN(Custrec)
  258.    GET #1, X, Custrec
  259.    IF LEFT$(Custrec.Company,7)="DELETED" THEN
  260.      Deleted=Deleted+1
  261.      Deleted(Deleted)=X
  262.    ELSE
  263.      Maxrows = Maxrows + 1
  264.      N$(Maxrows) = Custrec.Company
  265.      N(Maxrows) = X
  266.    END IF
  267.  NEXT
  268. END SUB
  269.  
  270. '------------------------------------------------------------------------------
  271. SUB Printrecords
  272. SHARED Maxrows,Currec,N(),N$()
  273.  COLOR 31,1
  274.  LOCATE 12,25:PRINT "Printing Records"
  275.  F$ = "\                          \  \                          \  \                            \  \                   \  \\ \            \"
  276.  LPRINT CHR$(15);
  277.  WIDTH "lpt1:", 132
  278.  FOR X = 1 TO LOF(1) / LEN(Custrec)
  279.    GET #1, X, Custrec
  280.    LPRINT USING F$; Custrec.Company; Custrec.Contact; Custrec.Address1; Custrec.City; Custrec.State; Custrec.Phone;
  281.  NEXT
  282.  COLOR 15,1
  283. END SUB
  284.  
  285. '------------------------------------------------------------------------------
  286. SUB Showcustomers
  287. SHARED Maxrows,Currec,N(),N$()
  288.  COLOR 15, 1: CLS
  289.  COLOR 15, 2
  290.  LOCATE 4, 3: PRINT CHR$(201) + STRING$(72, CHR$(205)) + CHR$(187)
  291.  FOR X = 1 TO 8
  292.    LOCATE X + 4, 3: PRINT CHR$(186) + SPACE$(72) + CHR$(186)
  293.  NEXT
  294.  LOCATE 12, 3: PRINT CHR$(200) + STRING$(72, CHR$(205)) + CHR$(188)
  295.  LOCATE 6, 10: PRINT "The text in the box below will show the"
  296.  LOCATE 7, 10: PRINT "customers you have.  You can scroll through"
  297.  LOCATE 8, 10: PRINT "them by using the ARROW keys."
  298.  IF MenuRow = 2 THEN
  299.    LOCATE 10, 10: PRINT "<RETURN> selects record for editing."
  300.  END IF
  301.  COLOR , 4
  302.  LOCATE 14, 3: PRINT CHR$(201) + STRING$(72, CHR$(205)) + CHR$(187)
  303.  FOR X = 1 TO 10
  304.    LOCATE X + 14, 3: PRINT CHR$(186) + SPACE$(72) + CHR$(186);
  305.  NEXT
  306.  LOCATE 24, 3: PRINT CHR$(200) + STRING$(72, CHR$(205)) + CHR$(188);
  307.  FOR X = 1 TO 9
  308.    COLOR 15, 4: LOCATE X + 14, 5: PRINT LEFT$(N$(X) + SPACE$(70), 70);
  309.  NEXT
  310.  COLOR 15, 3
  311.  LOCATE 24, 30: PRINT CHR$(24) + CHR$(25) + "      <RETURN> menu";
  312.  COLOR 15, 1
  313.  Row = 1: Extnd = 0: Currtop = 1
  314.  DO
  315.    COLOR 0, 7: LOCATE Row + 14, 5
  316.    PRINT LEFT$(N$(Row + Extnd) + SPACE$(70), 70);
  317.    Y$ = "": WHILE Y$ = "": Y$ = Inkey$: Wend: Y$ = UCASE$(Y$)
  318.    COLOR 15, 4: LOCATE Row + 14, 5
  319.    PRINT LEFT$(N$(Row + Extnd) + SPACE$(70), 70);
  320.    SELECT CASE Y$
  321.      CASE Esc$
  322.        COLOR 15, 1
  323.        CLS
  324.        EXIT SUB
  325.      CASE Enter$
  326.        COLOR 15, 1
  327.        IF MenuRow = 2 THEN Loadeditfield
  328.        CLS : EXIT SUB
  329.      CASE Pgup$
  330.        FOR Y = 1 TO 8
  331.          IF Row - 1 >= 1 THEN
  332.            Row = Row - 1
  333.          ELSE
  334.            IF Row = 1 AND Extnd > 0 THEN
  335.              Currtop = Currtop - 1
  336.              Extnd = Extnd - 1
  337.              GOSUB SCROLLONELINEDOWN
  338.            END IF
  339.          END IF
  340.        NEXT
  341.      CASE Uparrow$
  342.        IF Row - 1 >= 1 THEN
  343.          Row = Row - 1
  344.        ELSE
  345.          IF Row = 1 AND Extnd > 0 THEN
  346.            Currtop = Currtop - 1
  347.            Extnd = Extnd - 1
  348.            GOSUB SCROLLONELINEDOWN
  349.          END IF
  350.        END IF
  351.      CASE Pgdn$
  352.        FOR Y = 1 TO 8
  353.          IF Row + 1 + Extnd <= Maxrows THEN
  354.            Row = Row + 1
  355.            IF Row > 9 THEN
  356.              Currtop = Currtop + 1
  357.              Row = 9: Extnd = Extnd + 1
  358.              GOSUB SCROLLONELINEUP
  359.            END IF
  360.          END IF
  361.        NEXT
  362.      CASE Dnarrow$
  363.        IF Row + 1 + Extnd <= Maxrows THEN
  364.          Row = Row + 1
  365.          IF Row > 9 THEN
  366.            Currtop = Currtop + 1
  367.            Row = 9: Extnd = Extnd + 1
  368.            GOSUB SCROLLONELINEUP
  369.          END IF
  370.        END IF
  371.    END SELECT
  372.  LOOP
  373.  EXIT SUB
  374. SCROLLONELINEUP:
  375.  Srow = 15
  376.  FOR X = Currtop TO Currtop + 7
  377.    LOCATE Srow, 5: PRINT LEFT$(N$(X) + SPACE$(70), 70)
  378.    Srow = Srow + 1
  379.  NEXT
  380.  RETURN
  381. SCROLLONELINEDOWN:
  382.  Srow = 22
  383.  FOR X = Currtop + 7 TO Currtop STEP -1
  384.    LOCATE Srow, 5: PRINT LEFT$(N$(X) + SPACE$(70), 70);
  385.    Srow = Srow - 1
  386.  NEXT
  387.  RETURN
  388. END SUB
  389.  
  390. '------------------------------------------------------------------------------
  391. SUB Showmenu
  392. '*** make Menu Box
  393. MAKEMENU:
  394.  DO
  395.    CLS
  396.    COLOR 15, 4
  397.    LOCATE 4, 15: PRINT CHR$(201) + STRING$(50, CHR$(205)) + CHR$(187)
  398.    LOCATE 4, 30: PRINT "[ Ziggy's Main Menu ]"
  399.    FOR X = 1 TO 8
  400.      LOCATE X + 4, 15: PRINT CHR$(186) + SPACE$(50) + CHR$(186)
  401.    NEXT
  402.  
  403. '*** print Menu Selections
  404.    LOCATE 12, 15: PRINT CHR$(200) + STRING$(50, CHR$(205)) + CHR$(188)
  405.    FOR X = 1 TO 5: LOCATE X + 5, 16: PRINT Menu$(X): NEXT
  406.  
  407.    MenuRow = 1: Noofselections = 5
  408.    DO
  409.      COLOR 0, 7: LOCATE MenuRow + 5, 16: PRINT Menu$(MenuRow)
  410.      X$ = "": WHILE X$ = "": X$ = Inkey$: Wend: X$ = UCASE$(X$)
  411.      COLOR 15, 4: LOCATE MenuRow + 5, 16: PRINT Menu$(MenuRow)
  412.      SELECT CASE X$
  413.        CASE Esc$
  414.          COLOR 7, 0
  415.          CLS : END
  416.        CASE Enter$
  417.          SELECT CASE MenuRow
  418.            CASE 1  'view All Customers
  419.              CLS
  420.              Showcustomers
  421.              EXIT DO
  422.            CASE 2  'edit A Customer Record
  423.              CLS
  424.              Showcustomers
  425.              IF Y$ <> Esc$ THEN
  426.                Editcustomer
  427.              END IF
  428.              EXIT DO
  429.            CASE 3  'add A Customer Record
  430.              CLS
  431.              Editcustomer
  432.              EXIT DO
  433.            CASE 4  'print All Customer Records
  434.              CLS
  435.              Printrecords
  436.              EXIT DO
  437.            CASE 5  'quit
  438.              COLOR 7, 0
  439.              CLOSE : CLS : END
  440.          END SELECT
  441.        CASE Uparrow$
  442.          MenuRow = MenuRow - 1
  443.          IF MenuRow < 1 THEN MenuRow = Noofselections
  444.        CASE Dnarrow$
  445.          MenuRow = MenuRow + 1
  446.          IF MenuRow > Noofselections THEN MenuRow = 1
  447.      END SELECT
  448.    LOOP
  449.  LOOP
  450. END SUB
  451.  
  452. '------------------------------------------------------------------------------
  453. SUB Sortindex
  454. SHARED Maxrows,Currec,N(),N$()
  455.  IF Maxrows < 1 THEN EXIT SUB
  456.  Maxarray% = Maxrows
  457.  REDIM Stackl%(Maxarray%), Stackr%(Maxarray%)
  458.  Sx% = 1: Stackl%(1) = 1: Stackr%(1) = Maxarray%
  459.  WHILE Sx% <> 0
  460.    Lx% = Stackl%(Sx%): Rx% = Stackr%(Sx%): Sx% = Sx% - 1
  461.    WHILE Lx% < Rx%
  462.      Ix% = Lx%: Jx% = Rx%: X$ = N$((Lx% + Rx%) \ 2)
  463.      WHILE Ix% <= Jx%
  464.        WHILE N$(Ix%) < X$: Ix% = Ix% + 1: WEND
  465.        WHILE N$(Jx%) > X$: Jx% = Jx% - 1: WEND
  466.        X0% = 0
  467.        WHILE (Ix% <= Jx% AND X0% = 0)
  468.          X0% = 1: SWAP N$(Ix%), N$(Jx%)
  469.          SWAP N(Ix%), N(Jx%)
  470.          Ix% = Ix% + 1: Jx% = Jx% - 1
  471.        WEND
  472.      WEND
  473.      X0% = 0
  474.      WHILE (Ix% <= Rx% AND X0% = 0)
  475.        X0% = 1: Sx% = Sx% + 1
  476.        Stackl%(Sx%) = Ix%: Stackr%(Sx%) = Rx%
  477.      WEND
  478.      Rx% = Jx%
  479.    WEND
  480.  WEND
  481.  ERASE Stackl%, Stackr%
  482. END SUB
  483.  
  484. '------------------------------------------------------------------------------
  485. SUB Updaterec
  486. SHARED Maxrows,Currec,N(),N$()
  487.  PUT #1, Currec, Custrec
  488. END SUB
  489.